home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Pocket 6.3
/
Extensions
/
Starting
/
Brodie
next >
Wrap
Text File
|
1993-06-23
|
6KB
|
180 lines
\ Brodie v.1 Define some words to conform to Brodie's book.
0 28 +md ! forget task decimal page \ be neat
\
\ ------------------------------------------------
\ \|/ Drag the icon of this file to Pocket Forth, \|/
\ -X- then release the mouse button. That is, drop -X-
\ /|\ this file onto Pocket Forth, loading it. /|\
\ ------------------------------------------------
\
\ In order to use the book Starting Forth to learn Pocket
\ Forth, some definitions must be added to Pocket Forth. Load
\ this file to get partial compatability with Brodie's Forth.
\
\ Many of these definitions are machine language to give
\ maximum speed and take up minimum dictionary space.
\ Chapter 1
: SPACES ( n -- )
?dup IF 0 DO space LOOP THEN ; \ emit n spaces
\ Chapter 2
: D- dnegate d+ ; \ double length number subtraction
\ Display the contents of the stack from bottom to top.
: .S ( n[m] .. n[1] -- n[m] .. n[1] )
depth ?dup IF negate -1 DO \ contributed by
s0@ r 2* s>d d+ l@ . \ Jesus Consuegra
-1 +LOOP ELSE ." Empty" THEN ; \ * Thanks! *
\ Chapter 3
: .( 41 word here count type ; \ interactive printing utility
\ Chapter 4
: <> ( n1 n2 -- flag ) = 0= ; \ true if n1 and n2 are not the same
: NOT ( n -- not[n] ) -1 xor ; \ this is a bit not, not the same as 0=
\ Chapter 5
: 2- ( n -- n-2 ) ,$ 5556 ; MACRO \ subq #2,(ps)
: R@ ( -- n ) ( rstack: n -- n ) \ same as r
,$ 3d17 ; MACRO \ move (a7),-(a6)
\ Chapter 6
: I ( -- n ) ( rstack: n -- n ) ( same as r and r@ )
,$ 3d17 ; MACRO \ move (a7),-(a6)
: J ( -- n ) ( rstack: n x m -- n x m )
,$ 3d2f ,$ 0004 ; MACRO \ move 4(a7),-(a6)
\ Chapter 7
: OCTAL ( -- ) 8 base ! ;
: ASCII ( -- c ) \ ascii of next word *STATE SMART
32 word here 1+ c@ cstate c@ IF literal THEN ; IMMEDIATE
: D= ( d1 d2 -- flag ) d- + 0= ; \ true if d1=d2
: D< ( d1 d2 -- flag ) d- swap drop 0< ; \ true if d1<d2
: DMAX ( d1 d2 -- dmax ) \ dmax is the larger of d1 and d2
2over 2over d< IF 2swap THEN 2drop ;
: DMIN ( d1 d2 -- dmin ) \ dmin is the smaller of d1 and d2
2over 2over d< 0= IF 2swap THEN 2drop ;
: U< ( u1 u2 -- flag ) 0 rot 0 2swap d< ; \ true if u1<u2
: UM* ( u u -- d ) u* ; \ unsigned single multiply with double product
: M* ( n n -- d ) \ signed single multiply with double product
,$ 301E ,$ C1DE ,$ 2D00 ; \ move (ps)+,d0 muls (ps)+,d0 move.l d0,-(ps)
: UM/MOD ( d n -- urem uquot ) m/mod drop ;
: M/ ( d n -- quot ) m/mod rot 2drop ;
: M+ ( d n -- d[d+n] ) s>d d+ ;
: mst cr 9 spaces ." The word M*/ requires an 68020 or greater."
cr 9 spaces ." M*/ may give incorrect results."
cr 9 spaces ." (No other words are effected.)" cr cr cr ;
: mstest ( -- )
,s proc ?gestalt 0= IF \ check processor type
beep ." Caution: This is an old system." mst
ELSE drop 3 < IF \ must be 68020 or greater
beep beep beep ." Warning: This processor is too puny." mst
THEN THEN ;
mstest forget mst
: M*/ ( d n u -- d*n/u ) \ safe version -- will not crash on a 68000
,s proc ?gestalt swap drop and 2 > IF \ must be 68020 or greater
>r \ move (ps)+,-(rs)
,$ 4280 \ clr.l d0
,$ 4281 \ clr.l d1
,$ 321E \ move (ps)+,d1
,$ 4C16 ,$ 1C00 \ muls.l (ps),d0:d1 <-- 68020 instruction
,$ 4296 \ clr.l (a6)
,$ 3D5F ,$ 0002 \ move (rs)+,2(ps)
,$ 4C56 ,$ 1400 \ divu.l (ps),d0:d1 <-- 68020 instruction
,$ 2C81 \ move.l d1,(ps)
ELSE rot drop */ s>d THEN ; \ auto fall back to 16 bit version
\ Right justified numeric display.
: D.R ( d width -- )
>r swap over dabs <# #s sign #>
r> over - spaces type space ;
: .R ( n width -- ) >r s>d r> d.r ;
: U.R ( u width -- ) 0 swap d.r ;
\ Chapter 8
0 constant FALSE
-1 constant TRUE
: ? ( addr -- ) @ . ; ( print variable )
32 constant BL
: BLANK ( addr n -- ) bl fill ; \ Fill addr with n spaces.
: ERASE ( addr n -- ) 0 fill ; \ Fill addr with n zeros.
variable c,even -1 c,even !
: C, ( c -- ) \ NOTE: this allways leaves the address HERE even.
c,even @ IF here ! here 1+ c@ here c!
2 allot 0 c,even !
ELSE here 1- c! -1 c,even ! THEN ;
\ Chapter 9
: @EXECUTE ( addr -- ) @ ?dup IF execute THEN ;
: S0 ( -- dabs.addr ) S0@ ;
: ['] ( -- addr ) \ of the next word in a colon definition
token latest search IF literal
ELSE here count type space ." not found." abort
THEN ; IMMEDIATE
: RECURSE ( -- ) latest 6 + compile ;
variable eh
: H ( -- addr ) here eh ! eh ;
\ Chapter 10
: KEY? ( -- flag ) ?terminal ;
: MOVE ( addr1 addr2 count -- ) cmove ;
: CMOVE> ( addr1 addr2 count -- ) cmove ;
variable espan \ count of characters of the last EXPECTed input
: SPAN ( -- addr ) ,$ 3D07 ( move d7,-[ps] ) espan ! espan ;
variable in \ offset from tib of the current byte
: >IN ( -- addr ) ,$ 2D0C ( move.l is,-[ps] ) >rel tib - in ! in ;
variable tblk \ flag indicates input source
: BLK ( -- flag ) cblk c@ 0= tblk ! tblk ; \ true=file(paste)/false=keyboard
variable tstate
: STATE ( -- addr ) cstate c@ 0= 0= tstate ! tstate ;
: STRING ( c -- ) \ compile a string
word here c@ 1+ ,$ 5256 ,$ 256 ,$ fffe allot ; \ keep HERE even
: LIT" 34 string ; IMMEDIATE
\ These three words are redefined:
: (word) word ; .( WORD is redefined.) cr
: WORD ( c -- addr ) (word) here ;
: (number) number ; .( NUMBER is redefined.) cr
: NUMBER ( addr -- d ) (number) IF s>d ELSE 0 0 THEN ;
\ Chapter 11
.( COMPILE is redefined.) cr
: COMPILE ( -- ) \ compile the next word from within a colon def.
token latest search IF \ ( -- n ) addr of token
,$ 24FC ,$ 24FC ,$ 4EAB , \ move.l #[move.l jsr n(a3)],(a2)+
ELSE here count type space ." not found." abort
THEN ; IMMEDIATE
\ Restore the origonal WORD NUMBER and COMPILE by typing: FORGET (WORD)
: TASK ;
cr .( Welcome to Pocket Forth. ) cr cr
.( The extension file 'Brodie' has been loaded, providing) cr
.( substantial compatibility with Starting Forth.) cr cr
.( See 'To Use Starting Forth' for more information.) cr
-1 28 +md !